home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_LST.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-28  |  4KB  |  172 lines
  1. unit GS_Lst;
  2. {-----------------------------------------------------------------------------
  3.                              Printer Handler
  4.  
  5.        GS_Error Copyright (c)  Richard F. Griffin
  6.  
  7.        27 February 1992
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit replaces the Printer unit for output via the write(lst).
  14.        Error checking is done and a message is printed asking for operator
  15.        intervention.  Printing can be terminated by pressing the Escape key.
  16.        A flag, GS_Lst_Esc is set true if Escape is pressed, and can be used
  17.        by the program to test for that condition.  The program must reset
  18.        GS_Lst_Esc to false (GS_Lst_Esc := false) before trying to print
  19.        anything else, or the write command will be ignored.
  20.  
  21.    Changes:
  22.  
  23. ------------------------------------------------------------------------------}
  24.  
  25. interface
  26. {$D-}
  27. {$I-}
  28.  
  29. uses Crt, Dos, printer, GS_Error;
  30.  
  31. var
  32.   GS_Lst_Esc : boolean;
  33.   Lst: Text;
  34.  
  35. implementation
  36. type
  37.    s255 = string[255];
  38. var
  39.    Inch, Fnch : char;
  40.    SecNum : boolean;
  41.    KeyNum : integer;
  42.    TheStr : s255;
  43.  
  44. function GetKey : boolean;
  45. begin
  46.    GS_Lst_Esc := false;
  47.    if KeyPressed then begin
  48.       GetKey := true;
  49.       Inch := ReadKey;
  50.       KeyNum := ord(Inch);
  51.       Secnum := KeyNum = 0;
  52.       if Secnum then
  53.       begin
  54.          Fnch := ReadKey;
  55.          Keynum := ord(Fnch);
  56.       end
  57.       else if ord(Inch) <= 27 then Secnum := true else Secnum := false;
  58.    end
  59.    else begin
  60.       Getkey := false;
  61.       secnum := false;
  62.    end;
  63. end;
  64.  
  65. procedure Lst_Err;
  66. var
  67.   AsczStr : string[84];
  68. begin
  69.    gotoxy(2,14);
  70.    AsczStr := concat (#7,'Please Check Printer! ',#13,#10,
  71.                      'Use [ESC] to Exit, ',
  72.                      'Any Other Key to Continue.');
  73.    ShowError(162,AsczStr);
  74.    if (ErrorKey = #27) then GS_Lst_Esc := true;
  75. end;
  76.  
  77. procedure WriteLst;
  78. Label Skip;
  79. VAR
  80.   rgstr : Registers;
  81.   goodio : boolean;
  82.   i : integer;
  83. begin
  84.    goodio := false;
  85.    i := 0;
  86.    repeat
  87.       If GS_Lst_Esc then goto Skip;
  88.       {$I-} write(Printer.Lst,TheStr); {$I+}
  89.       goodio := ioresult = 0;
  90.       if not goodio then Lst_Err
  91.       else
  92.          if GetKey then
  93.             if (Secnum) and (Keynum = 27) then
  94.             begin
  95.                GS_Lst_Esc := true;
  96.                {$I-} writeln(Printer.Lst); {$I+}
  97.                goodio := ioresult = 0;
  98.             end;
  99.    until goodio or GS_Lst_Esc;
  100. Skip:
  101. end;
  102.  
  103. {$F+}
  104.  
  105. function LstInOut(var F : TextRec) : integer;
  106. var i : word;
  107. begin
  108.    with F do
  109.    begin
  110.       i := 0;
  111.       TheStr := '';
  112.       while i < BufPos do
  113.       begin
  114.          TheStr := TheStr + BufPtr^[i];
  115.          inc(i);
  116.       end;
  117.       WriteLst;
  118.       BufPos := 0;
  119.    end;
  120.    LstInOut := 0;
  121. end;
  122.  
  123. function LstClose(var F : TextRec) : integer;
  124. var i : word;
  125. begin
  126.    with F do
  127.    begin
  128.       i := 0;
  129.       TheStr := '';
  130.       while i < BufPos do
  131.       begin
  132.          TheStr := TheStr + BufPtr^[i];
  133.          inc(i);
  134.       end;
  135.       TheStr := TheStr + chr(10) + chr(13);
  136.       WriteLst;
  137.       BufPos := 0;
  138.    end;
  139.    LstClose := 0;
  140. end;
  141.  
  142.  
  143. function LstOpen(var F : TextRec) : integer;
  144. begin
  145.    with F do
  146.    begin
  147.       Mode := fmOutPut;
  148.       InOutFunc := @LstInOut;
  149.       FlushFunc := @LstInOut;
  150.       CloseFunc := @LstClose;
  151.       BufPos := 0;
  152.       LstOpen := 0;
  153.    end;
  154.    GS_Lst_Esc := false;
  155. end;
  156.  
  157. {$F-}
  158.  
  159. begin
  160.    with TextRec(Lst) do
  161.    begin
  162.       Handle := $FFFF;
  163.       Mode := fmClosed;
  164.       BufSize := Sizeof(Buffer);
  165.       BufPtr := @Buffer;
  166.       OpenFunc := @LstOpen;
  167.       Name[0] := #0;
  168.       Rewrite(Lst);
  169.    end;
  170.  
  171. end.
  172.